home *** CD-ROM | disk | FTP | other *** search
/ Programming Languages Suite / ProgLangD.iso / TURBOPASCAL WIN / DOCDEMOS.PAK / STEP09.PAS < prev    next >
Pascal/Delphi Source File  |  1992-06-08  |  8KB  |  321 lines
  1. {************************************************}
  2. {                                                }
  3. {   Turbo Pascal for Windows                     }
  4. {   Demo program                                 }
  5. {   Copyright (c) 1991 by Borland International  }
  6. {                                                }
  7. {************************************************}
  8.  
  9. program MyProgram;
  10.  
  11. uses Strings, WinTypes, WinProcs, WinDos, WObjects, StdDlgs;
  12.  
  13. {$R COOKBOOK.RES}
  14.  
  15. const
  16.   cm_New    = 101;
  17.   cm_Open   = 102;
  18.   cm_Save   = 103;
  19.   cm_SaveAs = 104;
  20.   cm_Help   = 901;
  21.  
  22. type
  23.   TMyApplication = object(TApplication)
  24.     procedure InitMainWindow; virtual;
  25.   end;
  26.  
  27. type
  28.   PMyWindow = ^TMyWindow;
  29.   TMyWindow = object(TWindow)
  30.     DragDC: HDC;
  31.     ButtonDown: Boolean;
  32.     ThePen: HPen;
  33.     PenSize: Integer;
  34.     Points: PCollection;
  35.     FileName: array[0..fsPathName] of Char;
  36.     IsDirty, IsNewFile: Boolean;
  37.     constructor Init(AParent: PWindowsObject; ATitle: PChar);
  38.     destructor Done; virtual;
  39.     function CanClose: Boolean; virtual;
  40.     procedure WMLButtonDown(var Msg: TMessage);
  41.       virtual wm_First + wm_LButtonDown;
  42.     procedure WMLButtonUp(var Msg: TMessage);
  43.       virtual wm_First + wm_LButtonUp;
  44.     procedure WMMouseMove(var Msg: TMessage);
  45.       virtual wm_First + wm_MouseMove;
  46.     procedure WMRButtonDown(var Msg: TMessage);
  47.       virtual wm_First + wm_RButtonDown;
  48.     procedure SetPenSize(NewSize: Integer);
  49.     procedure Paint(PaintDC: HDC; var PaintInfo: TPaintStruct); virtual;
  50.     procedure FileNew(var Msg: TMessage);
  51.       virtual cm_First + cm_New;
  52.     procedure FileOpen(var Msg: TMessage);
  53.       virtual cm_First + cm_Open;
  54.     procedure FileSave(var Msg: TMessage);
  55.       virtual cm_First + cm_Save;
  56.     procedure FileSaveAs(var Msg: TMessage);
  57.       virtual cm_First + cm_SaveAs;
  58.     procedure LoadFile;
  59.     procedure SaveFile;
  60.     procedure Help(var Msg: TMessage);
  61.       virtual cm_First + cm_Help;
  62.   end;
  63.  
  64. type
  65.   PDPoint = ^TDPoint;
  66.   TDPoint = object(TObject)
  67.     X, Y: Integer;
  68.     constructor Init(AX, AY: Integer);
  69.     constructor Load(var S: TStream);
  70.     procedure Store(var S: TStream);
  71.   end;
  72.  
  73. const
  74.   RDPoint: TStreamRec = (
  75.     ObjType: 200;
  76.     VmtLink: Ofs(TypeOf(TDPoint)^);
  77.     Load: @TDPoint.Load;
  78.     Store: @TDPoint.Store);
  79.  
  80. procedure StreamRegistration;
  81. begin
  82.   RegisterType(RCollection);
  83.   RegisterType(RDPoint);
  84. end;
  85.  
  86. {--------------------------------------------------}
  87. { TMyWindow's method implementations:              }
  88. {--------------------------------------------------}
  89.  
  90. constructor TMyWindow.Init(AParent: PWindowsObject; ATitle: PChar);
  91. begin
  92.   TWindow.Init(AParent, ATitle);
  93.   Attr.Menu := LoadMenu(HInstance, PChar(100));
  94.   ButtonDown := False;
  95.   PenSize := 1;
  96.   ThePen := CreatePen(ps_Solid, PenSize, 0);
  97.   Points := New(PCollection, Init(50, 50));
  98.   IsDirty := False;
  99.   IsNewFile := True;
  100.   StreamRegistration;
  101. end;
  102.  
  103. destructor TMyWindow.Done;
  104. begin
  105.   Dispose(Points, Done);
  106.   DeleteObject(ThePen);
  107.   TWindow.Done;
  108. end;
  109.  
  110. function TMyWindow.CanClose: Boolean;
  111. var
  112.   Reply : Integer;
  113. begin
  114.   CanClose := True;
  115.   if IsDirty then
  116.   begin
  117.     Reply := MessageBox(HWindow, 'Do you want to save?',
  118.       'Drawing has changed', mb_YesNo or mb_IconQuestion);
  119.     if Reply = id_Yes then CanClose := False;
  120.   end;
  121. end;
  122.  
  123. procedure TMyWindow.WMLButtonDown(var Msg: TMessage);
  124. begin
  125.   Points^.FreeAll;
  126.   InvalidateRect(HWindow, nil, True);
  127.   if not ButtonDown then
  128.   begin
  129.     IsDirty := True;
  130.     ButtonDown := True;
  131.     SetCapture(HWindow);
  132.     DragDC := GetDC(HWindow);
  133.     SelectObject(DragDC, ThePen);
  134.     MoveTo(DragDC, Msg.LParamLo, Msg.LParamHi);
  135.     Points^.Insert(New(PDPoint, Init(Msg.LParamLo, Msg.LParamHi)));
  136.   end;
  137. end;
  138.  
  139. procedure TMyWindow.WMMouseMove(var Msg: TMessage);
  140. begin
  141.   if ButtonDown then
  142.   begin
  143.     LineTo(DragDC, Integer(Msg.LParamLo), Integer(Msg.LParamHi));
  144.     Points^.Insert(New(PDPoint, Init(Integer(Msg.LParamLo), Integer(Msg.LParamHi))));
  145.   end;
  146. end;
  147.  
  148. procedure TMyWindow.WMLButtonUp(var Msg: TMessage);
  149. begin
  150.   if ButtonDown then
  151.   begin
  152.     ButtonDown := False;
  153.     ReleaseCapture;
  154.     ReleaseDC(HWindow, DragDC);
  155.   end;
  156. end;
  157.  
  158. procedure TMyWindow.WMRButtonDown(var Msg: TMessage);
  159. var
  160.   InputText: array[0..5] of Char;
  161.   NewSize, ErrorPos: Integer;
  162. begin
  163.   if not ButtonDown then
  164.   begin
  165.     Str(PenSize, InputText);
  166.     if Application^.ExecDialog(New(PInputDialog,
  167.       Init(@Self, 'Line Thickness', 'Input a new thickness:',
  168.         InputText, SizeOf(InputText)))) = id_Ok then
  169.     begin
  170.       Val(InputText, NewSize, ErrorPos);
  171.       if ErrorPos = 0 then SetPenSize(NewSize);
  172.     end;
  173.   end;
  174. end;
  175.  
  176. procedure TMyWindow.SetPenSize(NewSize: Integer);
  177. begin
  178.   DeleteObject(ThePen);
  179.   ThePen := CreatePen(ps_Solid, NewSize, 0);
  180.   PenSize := NewSize;
  181. end;
  182.  
  183. procedure TMyWindow.Paint(PaintDC: HDC; var PaintInfo: TPaintStruct);
  184. var
  185.   First: Boolean;
  186.  
  187. procedure DrawLine(P: PDPoint); far;
  188. begin
  189.   if First then MoveTo(PaintDC, P^.X, P^.Y)
  190.   else LineTo(PaintDC, P^.X, P^.Y);
  191.   First := False;
  192. end;
  193.  
  194. begin
  195.   SelectObject(PaintDC, ThePen);
  196.   First := True;
  197.   Points^.ForEach(@DrawLine);
  198. end;
  199.  
  200. procedure TMyWindow.FileNew(var Msg: TMessage);
  201. begin
  202.   Points^.FreeAll;
  203.   InvalidateRect(HWindow, nil, True);
  204.   IsDirty := False;
  205.   IsNewFile := True;
  206. end;
  207.  
  208. procedure TMyWindow.FileOpen(var Msg: TMessage);
  209. begin
  210.   if CanClose then
  211.     if Application^.ExecDialog(New(PFileDialog,
  212.         Init(@Self, PChar(sd_FileOpen),
  213.         StrCopy(FileName, '*.PTS')))) = id_Ok then
  214.       LoadFile;
  215. end;
  216.  
  217. procedure TMyWindow.FileSave(var Msg: TMessage);
  218. begin
  219.   if IsNewFile then FileSaveAs(Msg) else SaveFile;
  220. end;
  221.  
  222. procedure TMyWindow.FileSaveAs(var Msg: TMessage);
  223. var
  224.   FileDlg: PFileDialog;
  225. begin
  226.   if IsNewFile then StrCopy(FileName, '');
  227.   if Application^.ExecDialog(New(PFileDialog,
  228.       Init(@Self, PChar(sd_FileSave), FileName))) = id_Ok then
  229.     SaveFile;
  230. end;
  231.  
  232. procedure TMyWindow.LoadFile;
  233. var
  234.   TempColl: PCollection;
  235.   TheFile: TDosStream;
  236. begin
  237.   TheFile.Init(FileName, stOpen);
  238.   TempColl := PCollection(TheFile.Get);
  239.   TheFile.Done;
  240.   if TempColl <> nil then
  241.   begin
  242.     Dispose(Points, Done);
  243.     Points := TempColl;
  244.     InvalidateRect(HWindow, nil, True);
  245.   end;
  246.   IsDirty := False;
  247.   IsNewFile := False;
  248. end;
  249.  
  250.  
  251. procedure TMyWindow.SaveFile;
  252. var
  253.   TheFile: TDosStream;
  254. begin
  255.   TheFile.Init(FileName, stCreate);
  256.   TheFile.Put(Points);
  257.   TheFile.Done;
  258.   IsNewFile := False;
  259.   IsDirty := False;
  260. end;
  261.  
  262. procedure TMyWindow.Help(var Msg: TMessage);
  263. var
  264.   HelpWnd: PWindow;
  265. begin
  266.   HelpWnd := New(PWindow, Init(@Self, 'Help System'));
  267.   with HelpWnd^ do
  268.   begin
  269.     Attr.Style := ws_PopupWindow or ws_Caption or ws_Visible;
  270.     Attr.X := 100;
  271.     Attr.Y := 100;
  272.     Attr.W := 300;
  273.     Attr.H := 300;
  274.   end;
  275.   Application^.MakeWindow(HelpWnd);
  276. end;
  277.  
  278. {--------------------------------------------------}
  279. { TDPoints's method implementations:               }
  280. {--------------------------------------------------}
  281.  
  282. constructor TDPoint.Init(AX, AY: Integer);
  283. begin
  284.   X := AX;
  285.   Y := AY;
  286. end;
  287.  
  288. constructor TDPoint.Load(var S: TStream);
  289. begin
  290.   S.Read(X, SizeOf(X));
  291.   S.Read(Y, SizeOf(Y));
  292. end;
  293.  
  294. procedure TDPoint.Store(var S: TStream);
  295. begin
  296.   S.Write(X, SizeOf(X));
  297.   S.Write(Y, SizeOf(Y));
  298. end;
  299.  
  300. {--------------------------------------------------}
  301. { TMyApplication's method implementations:         }
  302. {--------------------------------------------------}
  303.  
  304. procedure TMyApplication.InitMainWindow;
  305. begin
  306.   MainWindow := New(PMyWindow, Init(nil, 'Sample ObjectWindows Program'));
  307. end;
  308.  
  309. {--------------------------------------------------}
  310. { Main program:                                    }
  311. {--------------------------------------------------}
  312.  
  313. var
  314.   MyApp : TMyApplication;
  315.  
  316. begin
  317.   MyApp.Init('MyProgram');
  318.   MyApp.Run;
  319.   MyApp.Done;
  320. end.
  321.